PC-X 1997 October/pcx14_9710.iso/swag/delphi.swg/0190_Collection Classes for DELPHI 2.0.pas

Pascal/Delphi Source File | 1996-11-29 | 9.4 KB | 321 lines

unit Collect;
{ Collection classes for Delphi 2.0
  Alin Flaider, 1996
  [e-mail] }

interface
uses Windows, Classes, Sysutils;

const
  coIndexError = -1;              { Index out of range }
  coOverflow   = -2;              { Overflow }
  coUnderflow  = -3;              { Underflow }

type
 CollException = class(Exception);

 TCollection = class( TObject)
    private                       { return item at index position }
       function    At( Index : integer) : Pointer;
                                  { replace item at index position}
       procedure   AtPut( Index : integer; Item : Pointer);
    protected
       It     : PPointerList;     { array of pointers }
       Limit  : integer;          { Current Allocated size of array}
       Delta  : integer;          {Number of items by which the collection grows when full}
                                  { deletes item at index position }
       procedure   AtDelete      (Index : integer);
                                  { generates CollException }
       procedure   Error         (Code,Info : Integer); virtual;
                                  { destroys specified Item; override this method if Item is not
                                    a descendant of TObject }
       procedure   FreeItem      (Item : Pointer); virtual;
    public
       Count  : integer;          {Current Number of Items}
       constructor create(aLimit, aDelta : integer);
                                  {before deallocating object it disposes all items and the storage array}
       destructor  destroy; override;
                                  {inserts Item at specified position }
       procedure   AtInsert( Index : integer; Item : Pointer);
                                  {deletes and disposes Item at specified position}
       procedure   AtFree(Index: Integer);
                                  {deletes Item}
       procedure   Delete( Item : Pointer);
                                  {deletes all Items without disposing them }
       procedure   DeleteAll;
                                  {formerly Free, renamed to Clear to avoid bypassing inherited TObject.Free;
                                   deletes and disposes Item }
       procedure Clear(Item: Pointer);
                                  {finds first item that satisfies condition specified in
                                   function Test( Item: pointer): boolean}
       function    FirstThat( Test : Pointer) : Pointer;
                                  {finds last item that satisfies condition specified in
                                   function Test( Item: pointer): boolean}
       function    LastThat( Test : Pointer) : Pointer;
                                  {calls procedure Action( Item: pointer) for each item in collection}
       procedure   ForEach( Action : Pointer);
                                  {disposes all items; set counter to zero}
       procedure   FreeAll;
                                  {finds position of Item using a linear search}
       function    IndexOf( Item : Pointer) : integer; virtual;
                                  {inserts Item at the end of collection}
       procedure   Insert( Item : Pointer); virtual;
                                  {packs collection by removing nil Items}
       procedure   Pack;
                                  {expands array of pointers }
       procedure   SetLimit( aLimit : integer);virtual;
                                  {direct access to items through position}
       property Items[Index: integer]: pointer read At write AtPut; default;
    end;

    TSortedCollection = class(TCollection)
       Duplicates: boolean;       {if true, rejects item whose key already exists}
                                  {override this method to specify relation bewtween two keys
                                  1 if Key1 comes after Key2, -1 if Key1 comes before Key2,
                                  0 if Key1 is equivalent to Key2}
       function Compare (Key1,Key2 : Pointer): Integer; virtual; abstract;
                                  {returns key of Item}
       function KeyOf   (Item : Pointer): Pointer; virtual;
                                  {finds index of item by calling Search}
       function IndexOf (Item : Pointer): integer; virtual;
                                  {finds item required position and performs insertion }
       procedure Insert  (Item : Pointer); virtual;
                                  {finds index of item by performing an optimised search}
       function Search  (key : Pointer; Var Index : integer) : Boolean; virtual;
    end;

implementation

constructor TCollection.Create(ALimit, ADelta: Integer);
begin
   inherited Create;
   Limit:= 0;
   Delta:=aDelta;
   Count:=0;
   It := nil;
   SetLimit( ALimit);
end;

destructor TCollection.Destroy;
begin
   FreeAll;
   SetLimit(0);
   inherited Destroy;
end;

function TCollection.At(Index: Integer): Pointer;
begin
   If Index > pred(Count) then
   begin
     Error(coIndexError,0);
     Result :=nil;
   end
   else Result := It^[Index];
end;

procedure TCollection.AtPut(Index: Integer; Item: Pointer);
begin
   if (Index < 0) or (Index >= Count) then
     Error(coIndexError,0)
   else It^[Index] := Item;
end;

procedure TCollection.AtDelete(Index: Integer);
var p: pointer;
begin
   if (Index < 0) or (Index >= Count) then
   begin
      Error(coIndexError,0);
      exit;
   end;
   if Index < pred(Count) then
     move( It^[succ(Index)], It^[Index], (count-index)*sizeof(pointer));
   Dec(Count);
end;

procedure TCollection.AtInsert( Index: integer; Item: pointer);
var i : integer;
begin
   if (Index < 0) or ( Index > Count) then
   begin
      Error(coIndexError,0);
      exit;
   end;
   if Limit = Count then
   begin
     if Delta = 0 then
     begin
        Error(coOverFlow,0);
        exit;
     end;
     SetLimit( Limit+Delta);
   end;
   If Index <> Count then  {move compensates for overlaps}
      move( It^[Index], It^[Index+1], (count - index)*sizeof(pointer));
   It^[Index] := Item;
   Inc(Count);
end;

procedure TCollection.Delete( Item: pointer);
begin
   AtDelete(Indexof(Item));
end;

procedure TCollection.DeleteAll;
begin
   Count:=0
end;

procedure TCollection.Error(Code, Info: Integer);
begin
   case Code of
        coIndexError: raise CollException.Create('Collection error; wrong index: '+IntToStr(Info));
        coOverflow:  raise CollException.Create('Collection overflow - cannot grow!');
        coUnderflow: raise CollException.Create('Collection underflow - cannot shrink!');
   end
end;

function TCollection.FirstThat(Test: Pointer): Pointer;
type
   tTestFunc = function( p : pointer) : Boolean;
var i : integer;
begin
  Result := nil;
  for i := 0 to pred(count) do
    if tTestFunc(test)(It^[i]) then begin
       Result := It[i];
       break
    end
end;

procedure TCollection.ForEach(Action: Pointer);
type
   tActionProc = procedure(p : pointer);
var i : integer;
begin
  for i := 0 to pred(Count) do
    tActionProc(Action)(It^[i]);
end;

procedure TCollection.Clear(Item: Pointer);
begin
   Delete(Item);
   FreeItem(Item);
end;

procedure TCollection.FreeAll;
var i : integer;
begin
  for I := 0 to Count - 1 do FreeItem(At(I));
  Count := 0;
end;

procedure TCollection.FreeItem(Item: Pointer);
begin
  if Item <> nil then TObject(Item).Free;
end;

function TCollection.IndexOf(Item: Pointer): integer;
var i : integer;
begin
  Result := -1;
  for i := 0 to pred(count) do
    if Item = It^[i] then begin
       Result := i;
       break
    end
end;

procedure TCollection.Insert(Item: Pointer);
begin
   AtInsert(Count,Item);
end;

function TCollection.LastThat(Test: Pointer): pointer;
type
   tTestFunc = function( p : pointer) : Boolean;
var i : integer;
begin
  Result := nil;
  for i := pred(count) downto 1 do
    if tTestFunc(test)(It^[i]) then begin
       Result := It^[i];
       break
    end
end;

procedure TCollection.Pack;
var i: integer;
begin
  for i := pred(count) downto 0 do if It^[i] = nil then AtDelete(i);
end;

procedure TCollection.SetLimit(ALimit: Integer);
begin
  if (ALimit < Count) then Error( coUnderFlow , 0);
  if ALimit <> Limit then
  begin
    ReallocMem( It, ALimit* SizeOf(Pointer));
    Limit := ALimit;
  end;
end;

function TSortedCollection.IndexOf(Item: Pointer): Integer;
var
  i: Integer;
begin
  IndexOf := -1;
  if Search(KeyOf(Item), i) then
  begin
    if Duplicates then
      while (i < Count) and (Item <> It^[I]) do Inc(i);
    if i < Count then IndexOf := i;
  end;
end;

procedure TSortedCollection.Insert(Item: Pointer);
var i : integer;
begin
  if not Search(KeyOf(Item), I) or Duplicates then AtInsert(I, Item);
end;

function TSortedCollection.KeyOf(Item: Pointer): Pointer;
begin
  Result := Item;
end;

function TSortedCollection.Search;
var
  L, H, I, C: Integer;
begin
  Search := False;
  L := 0;
  H := Count - 1;
  while L <= H do
  begin
    I := (L + H) shr 1;
    C := Compare(KeyOf(It^[I]), Key);
    if C < 0 then L := I + 1 else
    begin
      H := I - 1;
      if C = 0 then
      begin
        Search := True;
        if not Duplicates then L := I;
      end;
    end;
  end;
  Index := L;
end;

procedure TCollection.AtFree(Index: Integer);
var
  Item: Pointer;
begin
  Item := At(Index);
  AtDelete(Index);
  FreeItem(Item);
end;

end.